home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ADA Programming Guide
/
ADA Programming Guide.iso
/
ada_gnu
/
adainc
/
a-sequio.adb
< prev
next >
Wrap
Text File
|
1996-01-30
|
16KB
|
500 lines
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . S E Q U E N T I A L _ I O --
-- --
-- B o d y --
-- --
-- $Revision: 1.4 $ --
-- --
-- Copyright (c) 1992,1993,1994 NYU, All Rights Reserved --
-- --
-- The GNAT library is free software; you can redistribute it and/or modify --
-- it under terms of the GNU Library General Public License as published by --
-- the Free Software Foundation; either version 2, or (at your option) any --
-- later version. The GNAT library is distributed in the hope that it will --
-- be useful, but WITHOUT ANY WARRANTY; without even the implied warranty --
-- of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --
-- Library General Public License for more details. You should have --
-- received a copy of the GNU Library General Public License along with --
-- the GNAT library; see the file COPYING.LIB. If not, write to the Free --
-- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
-- --
------------------------------------------------------------------------------
with Ada.Storage_IO;
with Interfaces.C; use Interfaces.C;
with Interfaces.C.Strings; use Interfaces.C.Strings;
with System.File_Aux; use System.File_Aux;
package body Ada.Sequential_IO is
package Stor_IO is new Ada.Storage_IO (Element_Type => Element_Type);
type Pstring is access String;
type File_Control_Block is record
Name : chars_ptr := Null_Ptr;
Mode : File_Mode;
Form : Pstring;
Descriptor : C_File_Ptr;
Byte_Size : C_Long_Int;
Byte_Index : C_Long_Int;
end record;
type Open_Type is (Create, Open);
type C_Mode_Type is array (Open_Type, File_Mode) of chars_ptr;
C_Mode : C_Mode_Type := (others => (others => Null_Ptr));
Buffer : Stor_IO.Buffer_Type;
-----------------------
-- Local Subprograms --
-----------------------
procedure Confirm_File_Is_Open (File : in File_Type);
pragma Inline (Confirm_File_Is_Open);
-- Checks to make sure the given file is open.
-- If not, it raises Status_Error.
procedure Confirm_File_Is_Closed (File : in File_Type);
pragma Inline (Confirm_File_Is_Closed);
-- Checks to make sure the given file is closed.
-- If not, it raises Status_Error.
function Current_Size_Of (File : in File_Type) return C_Long_Int;
-- Returns the current size in bytes of the external file that is
-- associated with the given file. The given file must be open.
function New_Temp_File_Name return chars_ptr;
-- Returns a name that is a valid file name and that is not the same as
-- the name of an existing external file.
function File_Exists (Name : in String) return Boolean;
-- Returns True if an external file of the given name exists.
-- Otherwise, it returns False.
-----------
-- Close --
-----------
procedure Close (File : in out File_Type) is
begin
Confirm_File_Is_Open (File);
if C_Fclose (File.Descriptor) /= 0 then
raise Device_Error;
end if;
File := null;
end Close;
--------------------------
-- Confirm_File_Is_Open --
--------------------------
procedure Confirm_File_Is_Open (File : in File_Type) is
begin
if not Is_Open (File) then
raise Status_Error;
end if;
end Confirm_File_Is_Open;
----------------------------
-- Confirm_File_Is_Closed --
----------------------------
procedure Confirm_File_Is_Closed (File : in File_Type) is
begin
if Is_Open (File) then
raise Status_Error;
end if;
end Confirm_File_Is_Closed;
------------
-- Create --
------------
procedure Create
(File : in out File_Type;
Mode : in File_Mode := Out_File;
Name : in String := "";
Form : in String := "")
is
begin
Confirm_File_Is_Closed (File);
File := new File_Control_Block;
-- A null string for Name specifies creation of a temporary file.
if Name'Length = 0 then
File.Name := New_Temp_File_Name;
else
File.Name := New_String (Name);
end if;
File.Descriptor := C_Fopen (Filename => File.Name,
Mode => C_Mode (Create, Mode));
-- If the C fopen call fails, it returns a null pointer.
if C_Void_Ptr (File.Descriptor) = C_Null then
raise Name_Error;
end if;
File.Mode := Mode;
File.Form := new String'(Form);
-- The size of the external file is required in order to avoid
-- lookahead. In C, the end-of-file indicator is not considered to
-- be true until after an attempt is made to read past the end of the
-- external file. In Ada, the End_Of_File function returns True if no
-- more elements can be read (i.e. when reading elements, End_Of_File
-- becomes True before a failed read caused by end-of-file). In
-- Sequential_IO, it is sufficient to determine the size of the
-- external file once at the time of the opening of the file. The
-- End_Of_File function only operates on a file of mode In_File, and
-- such a file will not change in size.
File.Byte_Size := Current_Size_Of (File);
File.Byte_Index := 0;
end Create;
---------------------
-- Current_Size_Of --
---------------------
function Current_Size_Of (File : in File_Type) return C_Long_Int is
Current_Byte_Index : C_Long_Int;
Current_Byte_Size : C_Long_Int;
begin
Current_Byte_Index := C_Ftell (File.Descriptor);
if C_Fseek (Stream => File.Descriptor,
Offset => 0,
Whence => C_Seek_End) /= 0 then
raise Device_Error;
end if;
Current_Byte_Size := C_Ftell (File.Descriptor);
if C_Fseek (Stream => File.Descriptor,
Offset => Current_Byte_Index,
Whence => C_Seek_Set) /= 0 then
raise Device_Error;
end if;
return Current_Byte_Size;
end Current_Size_Of;
------------
-- Delete --
------------
procedure Delete (File : in out File_Type) is
File_Name_To_Delete : chars_ptr;
begin
Confirm_File_Is_Open (File);
-- The file should be closed before calling the C remove function.
-- If the file is open, the behavior of the remove function is
-- implementation-defined. Closing the file, however, means we
-- lose the info in the file control block, so we have to save the
-- file name temporarily in order to have it for use with the remove
-- function.
File_Name_To_Delete := File.Name;
Close (File);
if C_Remove (File_Name_To_Delete) /= 0 then
raise Use_Error;
end if;
end Delete;
-----------------
-- End_Of_File --
-----------------
function End_Of_File (File : in File_Type) return Boolean is
begin
Confirm_File_Is_Open (File);
if File.Mode /= In_File then
raise Mode_Error;
end if;
return File.Byte_Index >= File.Byte_Size;
end End_Of_File;
-----------------
-- File_Exists --
-----------------
function File_Exists (Name : in String) return Boolean is
File_Descriptor : C_File_Ptr;
C_Name : chars_ptr;
begin
C_Name := New_String (Name);
File_Descriptor := C_Fopen (Filename => C_Name,
Mode => C_Mode (Open, In_File));
if C_Void_Ptr (File_Descriptor) = C_Null then
return False;
end if;
if C_Fclose (File_Descriptor) /= 0 then
raise Device_Error;
end if;
return True;
end File_Exists;
----------
-- Form --
----------
function Form (File : in File_Type) return String is
begin
Confirm_File_Is_Open (File);
return File.Form.all;
end Form;
-------------
-- Is_Open --
-------------
function Is_Open (File : in File_Type) return Boolean is
begin
return File /= null;
end Is_Open;
----------
-- Mode --
----------
function Mode (File : in File_Type) return File_Mode is
begin
Confirm_File_Is_Open (File);
return File.Mode;
end Mode;
----------
-- Name --
----------
function Name (File : in File_Type) return String is
begin
Confirm_File_Is_Open (File);
return Value (File.Name);
end Name;
------------------------
-- New_Temp_File_Name --
------------------------
function New_Temp_File_Name return chars_ptr is
Temp_File_Name : String := "ADATMPXX";
C_Temp_File_Name : chars_ptr;
begin
C_Temp_File_Name := New_String (Temp_File_Name);
C_Temp_File_Name := C_Mktemp (C_Temp_File_Name);
return C_Temp_File_Name;
end New_Temp_File_Name;
----------
-- Open --
----------
procedure Open
(File : in out File_Type;
Mode : in File_Mode;
Name : in String;
Form : in String := "")
is
begin
Confirm_File_Is_Closed (File);
-- The language standard specifies that Name_Error must be raised if
-- no external file with the given name exists. This should occur
-- regardless of the given mode. The mode argument to the C fopen
-- function does not have sufficient flexibility to handle this
-- behavior with one call to fopen. In particular, opening a file with
-- mode Out_File should fail if the external file does not exist, but
-- should open and truncate the external file if it exists. The C
-- fopen funcation has no direct equivalent of this, as an fopen with
-- write mode succeeds whether the file exists or not. In order to
-- get the desired behavior in Ada, we need to do a separate check for
-- file existence prior to the C fopen call to open the file.
if not File_Exists (Name) then
raise Name_Error;
end if;
File := new File_Control_Block;
File.Name := New_String (Name);
File.Descriptor := C_Fopen (Filename => File.Name,
Mode => C_Mode (Open, Mode));
-- If the C fopen call fails, it returns a null pointer.
if C_Void_Ptr (File.Descriptor) = C_Null then
raise Name_Error;
end if;
File.Mode := Mode;
File.Form := new String'(Form);
-- The size of the external file is required in order to avoid
-- lookahead. In C, the end-of-file indicator is not considered to
-- be true until after an attempt is made to read past the end of the
-- external file. In Ada, the End_Of_File function returns True if no
-- more elements can be read (i.e. when reading elements, End_Of_File
-- becomes True before a failed read caused by end-of-file). In
-- Sequential_IO, it is sufficient to determine the size of the
-- external file once at the time of the opening of the file. The
-- End_Of_File function only operates on a file of mode In_File, and
-- such a file will not change in size.
File.Byte_Size := Current_Size_Of (File);
File.Byte_Index := 0;
end Open;
----------
-- Read --
----------
procedure Read (File : in File_Type; Item : out Element_Type) is
begin
Confirm_File_Is_Open (File);
if File.Mode /= In_File then
raise Mode_Error;
end if;
if End_Of_File (File) then
raise End_Error;
end if;
-- The C fread function returns the number of elements successfully
-- read. Since we only read one element at a time and we have already
-- checked for end of file, if the number of elements successfully read
-- does not equal the number of elements requested, it is considered to
-- be a Device_Error.
if C_Fread (Ptr => C_Void_Ptr (Buffer'Address),
Size => C_Size_T (Buffer'Length),
Nmemb => 1,
Stream => File.Descriptor) /= 1
then
raise Device_Error;
end if;
-- Advance the byte index so we can check for end of file.
File.Byte_Index := File.Byte_Index + Buffer'Length;
Stor_IO.Read (Buffer, Item);
end Read;
-----------
-- Reset --
-----------
procedure Reset (File : in out File_Type; Mode : in File_Mode) is
Old_File : File_Type := File;
begin
Confirm_File_Is_Open (File);
Close (File);
Open (File, Mode, Value (Old_File.Name), Old_File.Form.all);
end Reset;
procedure Reset (File : in out File_Type) is
begin
Confirm_File_Is_Open (File);
Reset (File, File.Mode);
end Reset;
-----------
-- Write --
-----------
procedure Write (File : in File_Type; Item : in Element_Type) is
begin
Confirm_File_Is_Open (File);
if File.Mode = In_File then
raise Mode_Error;
end if;
Stor_IO.Write (Buffer, Item);
-- The C fwrite function returns the number of elements successfully
-- written, which will less than the number of elements requested only
-- if a write error is encountered. Such a situation is considered to
-- be a Device_Error.
if C_Fwrite (Ptr => C_Void_Ptr (Buffer'Address),
Size => C_Size_T (Buffer'Length),
Nmemb => 1,
Stream => File.Descriptor) /= 1
then
raise Device_Error;
end if;
end Write;
begin
-------------------------
-- Package Elaboration --
-----------------
-- The following possible modes for the C fopen function are given here
-- for reference:
--
-- r open text file for reading
-- w truncate to zero length or create text file for writing
-- a append; open or create text file for writing at end-of-file
-- rb open binary file for reading
-- wb truncate to zero length or create binary file for writing
-- ab append; open or create binary file for writing at end-of-file
-- r+ open text file for update (reading and writing)
-- w+ truncate to zero length or create text file for update
-- a+ append; open or create text file for update, writing at end-of-file
-- rb+ open binary file for update (reading and writing)
-- wb+ truncate to zero length or create binary file for update
-- ab+ append; open or create binary file for update, writing at
-- end-of-file
--
-- Notes:
--
-- (1) Opening a file with read mode fails if the file does not exist or
-- cannot be read.
--
-- (2) Opening a file with append mode causes all subsequent writes to the
-- file to be forced to the then current end-of-file, regardless of
-- intervening calls to the fseek function.
--
-- (3) When a file is opened with update mode, both input and output may be
-- performed on the associated stream. However, output may not be directly
-- followed by input without an intervening call to the fflush function or
-- to a file positioning function (fseek, fsetpos, or rewind), and input
-- may not be directly followed by output without an intervening call to a
-- file positioning function, unless the input operation encounters
-- end-of-file.
C_Mode (Create, In_File) := New_String ("wb");
C_Mode (Create, Out_File) := New_String ("wb");
C_Mode (Create, Append_File) := New_String ("wb");
C_Mode (Open, In_File) := New_String ("rb");
C_Mode (Open, Out_File) := New_String ("wb");
C_Mode (Open, Append_File) := New_String ("ab");
end Ada.Sequential_IO;